Home

Column

NEON Ecological Forecasting Challenge sites

Column

Stats

Challenges

5

Teams

45

Total Forecasts

1195

Phenology

Column

Phenology (Greeness)

Phenology (Redness)

Column

Forecast Submissions

Teams

21

Leaderboard (target: greeness)

Leaderboard (target: redness)

Aquatics

Column

Aquatics Forecasts

Column

Leaderboard

Terrestrial

Column

Terrestrial Forecasts (Daily)

Terrestrial Forecasts (30 minute)

Column

Leaderboard (daily)

Leaderboard (30 minute)

Ticks

Column

Ticks

Column

Leaderboard

Beetles

Column

Beetles Forecasts

Column

Leaderboard

---
title: "NEON4CAST Dashboard"
output:
  flexdashboard::flex_dashboard:
    theme: 
      version: 4
      bootswatch: lux
    orientation: columns
    vertical_layout: fill
    source_code: embed
---

```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(plotly)
library(clock)
source("R/plotly_helpers.R")

thematic::thematic_rmd(font = "auto")
```


Home
=====



```{r include=FALSE}
combined <- read_csv("https://data.ecoforecast.org/analysis/combined_forecasts_scores.csv.gz")
```


Column {data-width=650}
-----------------------------------------------------------------------


### NEON Ecological Forecasting Challenge sites

```{r}
## FIXME color code by number of challenges at each site?

challenges <- combined %>% select(theme, siteID) %>% distinct() %>%
  separate(siteID, into = c("siteID", "plot")) %>%
  select(theme, siteID) %>% 
  distinct() 
  
library(sf)
library(tmap)
geo <- jsonlite::read_json("https://github.com/eco4cast/neon4cast/raw/main/inst/extdata/geo.json", TRUE)
site_id <- gsub(", .*$", "", geo$geographicDescription)
bb <- geo$boundingCoordinates[1:4] %>% mutate_all(as.numeric) %>% mutate(siteID = site_id)
bb <- left_join(bb, challenges, by = "siteID")
neon <- st_as_sf(bb, coords = c("westBoundingCoordinate", "northBoundingCoordinate"), crs = 4326)

tmap::tmap_mode("view")
tm_shape(neon) + tm_dots(col="theme", alpha=.4, size = .1)
```

Column {data-width=350}
-----------------------------------------------------------------------

## Stats

### Challenges 


```{r}
flexdashboard::valueBox(5, color = "primary")
```

### Teams

```{r}
total_teams <- combined %>% select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total_teams, color = "success")
```



### Total Forecasts

```{r}
total_forecasts <- combined %>% select(team, forecast_start_time) %>% distinct() %>% count()
flexdashboard::valueBox(total_forecasts, color = "info")
```





Phenology
==========


Column {data-width=650}
-----------------------------------------------------------------------

### Phenology (Greeness)

```{r}
## determine these more cleverly
start <- as.Date("2021-05-01")
end <- Sys.Date() %>% clock::add_months(1)

## Get most recent submission per team
pheno_teams <- combined %>% filter(theme == "phenology") %>%
  select(team, forecast_start_time) %>% distinct() %>%
  group_by(team) %>%
  slice_max(forecast_start_time)

pheno_latest <- inner_join(pheno_teams, combined)

p <- pheno_latest %>% 
  filter(time > start, time < end, target == "gcc_90") %>%
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs), size = .1) + 
  facet_wrap(~siteID)

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```
### Phenology (Redness)

```{r}
p <- pheno_latest %>% 
  filter(time > start, time < end, target == "rcc_90") %>%
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs), size = .1) + 
  facet_wrap(~siteID)

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```
Column {data-width=350}
-----------------------------------------------------------------------

### Forecast Submissions

```{r}
pheno_forecasts <- combined %>% filter(theme == "phenology") %>%
  select(team, forecast_start_time) %>% distinct() %>% count()

gauge(100* pheno_forecasts[[1]]/total_forecasts[[1]], min = 0, max = 100, symbol = '%', gaugeSectors(
  success = c(80, 100), warning = c(40, 79), danger = c(0, 39)
))
```

### Teams

```{r}
total <- combined %>% filter(theme == "phenology") %>% select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total)
```

### Leaderboard (target: greeness)

```{r}
combined %>% 
  filter(theme == "phenology", target == "gcc_90", !is.na(crps)) %>% 
  group_by(team) %>%
  summarise(mean_crps = mean(crps),
            total_forecasted_days = n()) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```

### Leaderboard (target: redness)

```{r}

combined %>% 
  filter(theme == "phenology", target == "rcc_90") %>% 
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE),
            total_forecasted_days = n()) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```

Aquatics
========

Column {data-width=650}
-----------------------------------------------------------------------


### Aquatics Forecasts

```{r}

## Could consider displaying older ones
start <- combined %>% 
  filter(theme == "aquatics") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "aquatics", forecast_start_time == start[[2,1]], target == "temperature") %>%
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs)) + 
  facet_wrap(target~siteID, scales = "free")

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```

Column {data-width=350}
-----------------------------------------------------------------------


### Leaderboard

```{r}
combined %>% 
  filter(theme == "aquatics") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```

Terrestrial
===========

Column {data-width=650}
-----------------------------------------------------------------------

### Terrestrial Forecasts (Daily)

```{r}
## Could consider displaying older ones
start <- combined %>% 
  filter(theme == "terrestrial_daily") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "terrestrial_daily", forecast_start_time == start[[2,1]]) %>%
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs)) + 
  facet_grid(target ~ siteID, scales = "free")

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```


### Terrestrial Forecasts (30 minute)

```{r}
## Could consider displaying older ones
start <- combined %>% 
  filter(theme == "terrestrial_30min") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "terrestrial_30min", forecast_start_time == start[[2,1]]) %>%
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs)) + 
  facet_grid(target ~ siteID, scales = "free")

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```

Column {data-width=350}
-----------------------------------------------------------------------


### Leaderboard (daily)

```{r}
combined %>% 
  filter(theme == "terrestrial_daily") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```
### Leaderboard (30 minute)

```{r}
combined %>% 
  filter(theme == "terrestrial_30min") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```

Ticks
=======

Column {data-width=650}
-----------------------------------------------------------------------

### Ticks

```{r}
## Could consider displaying older ones
start <- combined %>% 
  filter(theme == "ticks") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "ticks", forecast_start_time == start[[2,1]]) %>% # second most recent start time
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team, lty=target), alpha = 0.2) +
  geom_line(aes(time, mean, col = team, lty=target)) +
  geom_point(aes(time, obs, shape=target)) + 
  facet_wrap(~siteID)

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```


Column {data-width=350}
-----------------------------------------------------------------------

### Leaderboard

```{r}
combined %>% 
  filter(theme == "ticks") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```


Beetles
=======

Column {data-width=650}
-----------------------------------------------------------------------

### Beetles Forecasts

```{r}
## determine these more cleverly
start <- combined %>% 
  filter(theme == "beetles") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "beetles", forecast_start_time == start[[1,1]]) %>% # second most recent start time
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs)) + 
  facet_wrap(~target)


gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```


Column {data-width=350}
-----------------------------------------------------------------------


### Leaderboard

```{r}
combined %>% 
  filter(theme == "beetles") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```